home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / lsp / setf.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  18KB  |  474 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;        setf.lsp
  6. ;;;;
  7. ;;;;                                setf routines
  8.  
  9.  
  10. (in-package 'lisp)
  11.  
  12.  
  13. (export '(setf psetf shiftf rotatef
  14.           define-modify-macro defsetf
  15.           getf remf incf decf push pushnew pop
  16.           define-setf-method get-setf-method get-setf-method-multiple-value))
  17.  
  18.  
  19. (in-package 'system)
  20.  
  21.  
  22. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  23. (eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
  24. (eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
  25.  
  26.  
  27. ;;; DEFSETF macro.
  28. (defmacro defsetf (access-fn &rest rest)
  29.   (cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest))))
  30.          `(progn (si:putprop ',access-fn ',(car rest) 'setf-update-fn)
  31.                  (remprop ',access-fn 'setf-lambda)
  32.                  (remprop ',access-fn 'setf-method)
  33.                  (si:putprop ',access-fn
  34.                              ,(when (not (endp (cdr rest)))
  35.                                     (unless (stringp (cadr rest))
  36.                                             (error "A doc-string expected."))
  37.                                     (unless (endp (cddr rest))
  38.                                             (error "Extra arguments."))
  39.                                     (cadr rest))
  40.                              'setf-documentation)
  41.                  ',access-fn))
  42.     (t
  43.      (unless (= (list-length (cadr rest)) 1)
  44.          (error "(store-variable) expected."))
  45.          `(progn (si:putprop ',access-fn ',rest 'setf-lambda)
  46.                  (remprop ',access-fn 'setf-update-fn)
  47.                  (remprop ',access-fn 'setf-method)
  48.                  (si:putprop ',access-fn
  49.                              ,(find-documentation (cddr rest))
  50.                              'setf-documentation)
  51.                  ',access-fn))))
  52.  
  53.  
  54. ;;; DEFINE-SETF-METHOD macro.
  55. (defmacro define-setf-method (access-fn &rest rest)
  56.   `(progn (si:putprop ',access-fn #'(lambda ,@rest) 'setf-method)
  57.           (remprop ',access-fn 'setf-lambda)
  58.           (remprop ',access-fn 'setf-update-fn)
  59.           (si:putprop ',access-fn
  60.                       ,(find-documentation (cdr rest))
  61.                       'setf-documentation)
  62.           ',access-fn))
  63.  
  64.  
  65. ;;; GET-SETF-METHOD.
  66. ;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE
  67. ;;;  and checks the number of the store variable.
  68. (defun get-setf-method (form)
  69.   (multiple-value-bind (vars vals stores store-form access-form)
  70.       (get-setf-method-multiple-value form)
  71.     (unless (= (list-length stores) 1)
  72.         (error "Multiple store-variables are not allowed."))
  73.     (values vars vals stores store-form access-form)))
  74.  
  75.  
  76. ;;;; GET-SETF-METHOD-MULTIPLE-VALUE.
  77.  
  78. (defun get-setf-method-multiple-value (form)
  79.   (cond ((symbolp form)
  80.      (let ((store (gensym)))
  81.        (values nil nil (list store) `(setq ,form ,store) form)))
  82.     ((or (not (consp form)) (not (symbolp (car form))))
  83.      (error "Cannot get the setf-method of ~S." form))
  84.     ((get (car form) 'setf-method)
  85.      (apply (get (car form) 'setf-method) (cdr form)))
  86.     ((get (car form) 'setf-update-fn)
  87.      (let ((vars (mapcar #'(lambda (x)
  88.                              (declare (ignore x))
  89.                              (gensym))
  90.                          (cdr form)))
  91.            (store (gensym)))
  92.        (values vars (cdr form) (list store)
  93.                `(,(get (car form) 'setf-update-fn)
  94.              ,@vars ,store)
  95.            (cons (car form) vars))))
  96.     ((get (car form) 'setf-lambda)
  97.      (let* ((vars (mapcar #'(lambda (x)
  98.                               (declare (ignore x))
  99.                               (gensym))
  100.                           (cdr form)))
  101.         (store (gensym))
  102.         (l (get (car form) 'setf-lambda))
  103.         (f `(lambda ,(car l) #'(lambda ,(cadr l) ,@(cddr l)))))
  104.        (values vars (cdr form) (list store)
  105.            (funcall (apply f vars) store)
  106.            (cons (car form) vars))))
  107.     ((macro-function (car form))
  108.      (get-setf-method-multiple-value (macroexpand form)))
  109.     (t
  110.      (error "Cannot expand the SETF form ~S." form))))
  111.  
  112.  
  113. ;;;; SETF definitions.
  114.  
  115. (defsetf car (x) (y) `(progn (rplaca ,x ,y) ,y))
  116. (defsetf cdr (x) (y) `(progn (rplacd ,x ,y), y))
  117. (defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y))
  118. (defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y))
  119. (defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
  120. (defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y))
  121. (defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y))
  122. (defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y))
  123. (defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y))
  124. (defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y))
  125. (defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y))
  126. (defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y))
  127. (defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
  128. (defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y))
  129. (defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y))
  130. (defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y))
  131. (defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y))
  132. (defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y))
  133. (defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y))
  134. (defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y))
  135. (defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y))
  136. (defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y))
  137. (defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y))
  138. (defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y))
  139. (defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y))
  140. (defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y))
  141. (defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y))
  142. (defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y))
  143. (defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
  144. (defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y))
  145. (defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y))
  146. (defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
  147. (defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
  148. (defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
  149. (defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y))
  150. (defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y))
  151. (defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y))
  152. (defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y))
  153. (defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y))
  154. (defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y))
  155. (defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y))
  156. (defsetf svref si:svset)
  157. (defsetf elt si:elt-set)
  158. (defsetf symbol-value set)
  159. (defsetf symbol-function si:fset)
  160. (defsetf macro-function (s) (v) `(progn (si:fset ,s (cons 'macro ,v)) ,v))
  161. (defsetf aref si:aset)
  162. (defsetf get (s p &optional d) (v) `(si:putprop ,s ,v ,p))
  163. (defsetf nth (n l) (v) `(progn (rplaca (nthcdr ,n ,l) ,v) ,v))
  164. (defsetf char si:char-set)
  165. (defsetf schar si:schar-set)
  166. (defsetf bit si:aset)
  167. (defsetf sbit si:aset)
  168. (defsetf fill-pointer si:fill-pointer-set)
  169. (defsetf symbol-plist si:set-symbol-plist)
  170. (defsetf gethash (k h &optional d) (v) `(si:hash-set ,k ,h ,v))
  171. (defsetf documentation (s d) (v)
  172.   `(case ,d
  173.      (variable (si:putprop ,s ,v 'variable-documentation))
  174.      (function (si:putprop ,s ,v 'function-documentation))
  175.      (structure (si:putprop ,s ,v 'structure-documentation))
  176.      (type (si:putprop ,s ,v 'type-documentation))
  177.      (setf (si:putprop ,s ,v 'setf-documentation))
  178.      (t (error "~S is an illegal documentation type." ,d))))
  179.  
  180.  
  181. (define-setf-method getf (place indicator &optional default)
  182.   (multiple-value-bind (vars vals stores store-form access-form)
  183.       (get-setf-method place)
  184.     (let ((itemp (gensym)) (store (gensym)))
  185.       (values `(,@vars ,itemp)
  186.               `(,@vals ,indicator)
  187.               (list store)
  188.               `(let ((,(car stores) (si:put-f ,access-form ,store ,itemp)))
  189.                  ,store-form
  190.                  ,store)
  191.               `(getf ,access-form ,itemp ,default)))))
  192.  
  193. (defsetf subseq (sequence1 start1 &optional end1)
  194.         (sequence2)
  195.   `(replace ,sequence1 ,sequence2 :start1 ,start1 :end1 ,end1))
  196.  
  197. (define-setf-method the (type form)
  198.   (multiple-value-bind (vars vals stores store-form access-form)
  199.       (get-setf-method form)
  200.     (let ((store (gensym)))
  201.       (values vars vals (list store)
  202.           `(let ((,(car stores) (the ,type ,store))) ,store-form)
  203.           `(the ,type ,access-form)))))
  204.  
  205. #|
  206. (define-setf-method apply (fn &rest rest)
  207.   (unless (and (consp fn) (eq (car fn) 'function) (symbolp (cadr fn))
  208.            (null (cddr fn)))
  209.       (error "Can't get the setf-method of ~S." fn))
  210.   (multiple-value-bind (vars vals stores store-form access-form)
  211.       (get-setf-method (cons (cadr fn) rest))
  212.     (unless (eq (car (last store-form)) (car (last vars)))
  213.             (error "Can't get the setf-method of ~S." fn))
  214.     (values vars vals stores
  215.         `(apply #',(car store-form) ,@(cdr store-form))
  216.         `(apply #',(cadr fn) ,@(cdr access-form)))))
  217. |#
  218.  
  219. (define-setf-method apply (fn &rest rest)
  220.   (unless (and (consp fn)
  221.                (or (eq (car fn) 'function) (eq (car fn) 'quote))
  222.                (symbolp (cadr fn))
  223.                (null (cddr fn)))
  224.     (error "Can't get the setf-method of ~S." fn))
  225.   (multiple-value-bind (vars vals stores store-form access-form)
  226.       (get-setf-method (cons (cadr fn) rest))
  227.     (cond ((eq (car (last store-form)) (car (last vars)))
  228.            (values vars vals stores
  229.                    `(apply #',(car store-form) ,@(cdr store-form))
  230.                    `(apply #',(cadr fn) ,@(cdr access-form))))
  231.           ((eq (car (last (butlast store-form))) (car (last vars)))
  232.            (values vars vals stores
  233.                    `(apply #',(car store-form)
  234.                            ,@(cdr (butlast store-form 2))
  235.                            (append ,(car (last (butlast store-form)))
  236.                                    (list ,(car (last store-form)))))
  237.                    `(apply #',(cadr fn) ,@(cdr access-form))))
  238.           (t (error "Can't get the setf-method of ~S." fn)))))
  239.  
  240. (define-setf-method char-bit (char name)
  241.   (multiple-value-bind (temps vals stores store-form access-form)
  242.       (get-setf-method char)
  243.     (let ((ntemp (gensym))
  244.       (store (gensym))
  245.       (stemp (first stores)))
  246.       (values `(,ntemp ,@temps)
  247.           `(,name ,@vals)
  248.           (list store)
  249.           `(let ((,stemp (set-char-bit ,access-form ,ntemp ,store)))
  250.              ,store-form ,store)
  251.           `(char-bit ,access-form ,ntemp)))))
  252.  
  253. (define-setf-method ldb (bytespec int)
  254.   (multiple-value-bind (temps vals stores store-form access-form)
  255.       (get-setf-method int)
  256.     (let ((btemp (gensym))
  257.       (store (gensym))
  258.       (stemp (first stores)))
  259.       (values `(,btemp ,@temps)
  260.           `(,bytespec ,@vals)
  261.           (list store)
  262.           `(let ((,stemp (dpb ,store ,btemp ,access-form)))
  263.              ,store-form ,store)
  264.           `(ldb ,btemp ,access-form)))))
  265.  
  266. (define-setf-method mask-field (bytespec int)
  267.   (multiple-value-bind (temps vals stores store-form access-form)
  268.       (get-setf-method int)
  269.     (let ((btemp (gensym))
  270.       (store (gensym))
  271.       (stemp (first stores)))
  272.       (values `(,btemp ,@temps)
  273.           `(,bytespec ,@vals)
  274.           (list store)
  275.           `(let ((,stemp (deposit-field ,store ,btemp ,access-form)))
  276.              ,store-form ,store)
  277.           `(mask-field ,btemp ,access-form)))))
  278.  
  279.  
  280. ;;; The expansion function for SETF.
  281. (defun setf-expand-1 (place newvalue &aux g)
  282.   (when (and (consp place) (eq (car place) 'the))
  283.         (return-from setf-expand-1
  284.           (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue))))
  285.   (when (symbolp place)
  286.         (return-from setf-expand-1 `(setq ,place ,newvalue)))
  287.   (when (and (symbolp (car place)) (setq g (get (car place) 'setf-update-fn)))
  288.         (return-from setf-expand-1 `(,g ,@(cdr place) ,newvalue)))
  289.   (when (and (symbolp (car place))
  290.              (setq g (get (car place) 'structure-access))
  291.              (get (car place) 'setf-lambda)
  292.              (not (eq (car g) 'list))
  293.              (not (eq (car g) 'vector)))
  294.         (return-from setf-expand-1
  295.           `(si:structure-set ,(cadr place) ',(car g) ,(cdr g) ,newvalue)))
  296.   (multiple-value-bind (vars vals stores store-form access-form)
  297.       (get-setf-method place)
  298.     (declare (ignore access-form))
  299.     `(let* ,(mapcar #'list
  300.             (append vars stores)
  301.             (append vals (list newvalue)))
  302.        ,store-form)))
  303.  
  304. (defun setf-expand (l)
  305.   (cond ((endp l) nil)
  306.         ((endp (cdr l)) (error "~S is an illegal SETF form." l))
  307.         (t
  308.          (cons (setf-expand-1 (car l) (cadr l))
  309.                (setf-expand (cddr l))))))
  310.  
  311.  
  312. ;;; SETF macro.
  313. (defmacro setf (&rest rest)
  314.   (cond ((endp rest) nil)
  315.         ((endp (cdr rest)) (error "~S is an illegal SETF form." rest))
  316.         ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest)))
  317.         (t (cons 'progn (setf-expand rest)))))
  318.  
  319.  
  320. ;;; PSETF macro.
  321.  
  322. (defmacro psetf (&rest rest)
  323.   (cond ((endp rest) nil)
  324.         ((endp (cdr rest)) (error "~S is an illegal PSETF form." rest))
  325.         ((endp (cddr rest))
  326.          `(progn ,(setf-expand-1 (car rest) (cadr rest))
  327.                  nil))
  328.         (t
  329.      (do ((r rest (cddr r))
  330.           (pairs nil)
  331.           (store-forms nil))
  332.          ((endp r)
  333.           `(let* ,pairs
  334.          ,@(nreverse store-forms)
  335.          nil))
  336.        (when (endp (cdr r)) (error "~S is an illegal PSETF form." rest))
  337.        (multiple-value-bind (vars vals stores store-form access-form)
  338.            (get-setf-method (car r))
  339.              (declare (ignore access-form))
  340.          (setq store-forms (cons store-form store-forms))
  341.          (setq pairs
  342.            (nconc pairs
  343.               (mapcar #'list
  344.                   (append vars stores)
  345.                   (append vals (list (cadr r)))))))))))
  346.  
  347.  
  348. ;;; SHIFTF macro.
  349. (defmacro shiftf (&rest rest)
  350.   (do ((r rest (cdr r))
  351.        (pairs nil)
  352.        (stores nil)
  353.        (store-forms nil)
  354.        (g (gensym))
  355.        (access-forms nil))
  356.       ((endp (cdr r))
  357.        (setq stores (nreverse stores))
  358.        (setq store-forms (nreverse store-forms))
  359.        (setq access-forms (nreverse access-forms))
  360.        `(let* ,(nconc pairs
  361.               (list (list g (car access-forms)))
  362.               (mapcar #'list stores (cdr access-forms))
  363.               (list (list (car (last stores)) (car r))))
  364.         ,@store-forms
  365.         ,g))
  366.     (multiple-value-bind (vars vals stores1 store-form access-form)
  367.     (get-setf-method (car r))
  368.       (setq pairs (nconc pairs (mapcar #'list vars vals)))
  369.       (setq stores (cons (car stores1) stores))
  370.       (setq store-forms (cons store-form store-forms))
  371.       (setq access-forms (cons access-form access-forms)))))
  372.  
  373.  
  374. ;;; ROTATEF macro.
  375. (defmacro rotatef (&rest rest)
  376.   (do ((r rest (cdr r))
  377.        (pairs nil)
  378.        (stores nil)
  379.        (store-forms nil)
  380.        (access-forms nil))
  381.       ((endp r)
  382.        (setq stores (nreverse stores))
  383.        (setq store-forms (nreverse store-forms))
  384.        (setq access-forms (nreverse access-forms))
  385.        `(let* ,(nconc pairs
  386.               (mapcar #'list stores (cdr access-forms))
  387.               (list (list (car (last stores)) (car access-forms))))
  388.         ,@store-forms))
  389.     (multiple-value-bind (vars vals stores1 store-form access-form)
  390.     (get-setf-method (car r))
  391.       (setq pairs (nconc pairs (mapcar #'list vars vals)))
  392.       (setq stores (cons (car stores1) stores))
  393.       (setq store-forms (cons store-form store-forms))
  394.       (setq access-forms (cons access-form access-forms)))))
  395.  
  396.  
  397. ;;; DEFINE-MODIFY-MACRO macro.
  398. (defmacro define-modify-macro (name lambda-list function &optional doc-string)
  399.   (let ((update-form
  400.      (do ((l lambda-list (cdr l))
  401.           (vs nil))
  402.          ((null l) `(list ',function access-form ,@(nreverse vs)))
  403.        (unless (eq (car l) '&optional)
  404.            (if (eq (car l) '&rest)
  405.                (return `(list* ',function
  406.                        access-form
  407.                        ,@(nreverse vs)
  408.                        ,(cadr l))))
  409.            (if (symbolp (car l))
  410.                (setq vs (cons (car l) vs))
  411.                (setq vs (cons (caar l) vs)))))))
  412.     `(defmacro ,name (reference . ,lambda-list)
  413.        ,@(if doc-string (list doc-string))
  414.        (when (symbolp reference)
  415.              (return-from ,name
  416.                (let ((access-form reference))
  417.                  (list 'setq reference ,update-form))))
  418.        (multiple-value-bind (vars vals stores store-form access-form)
  419.        (get-setf-method reference)
  420.          (list 'let*
  421.            (mapcar #'list
  422.                (append vars stores)
  423.                (append vals (list ,update-form)))
  424.            store-form))))))))))))))))))))
  425.  
  426.  
  427. ;;; Some macro definitions.
  428.  
  429. (defmacro remf (place indicator)
  430.   (multiple-value-bind (vars vals stores store-form access-form)
  431.       (get-setf-method place)
  432.     `(let* ,(mapcar #'list vars vals)
  433.        (multiple-value-bind (,(car stores) flag)
  434.            (si:rem-f ,access-form ,indicator)
  435.          ,store-form
  436.          flag))))
  437.  
  438. (define-modify-macro incf (&optional (delta 1)) +)
  439. (define-modify-macro decf (&optional (delta 1)) -)
  440.  
  441. (defmacro push (item place)
  442.   (when (symbolp place)
  443.         (return-from push `(setq ,place (cons ,item ,place))))
  444.   (multiple-value-bind (vars vals stores store-form access-form)
  445.       (get-setf-method place)
  446.     `(let* ,(mapcar #'list
  447.             (append vars stores)
  448.             (append vals (list (list 'cons item access-form))))
  449.        ,store-form)))
  450.  
  451. (defmacro pushnew (item place &rest rest)
  452.   (multiple-value-bind (vars vals stores store-form access-form)
  453.       (get-setf-method place)
  454.     `(let* ,(mapcar #'list
  455.             (append vars stores)
  456.             (append vals
  457.                 (list (list* 'adjoin item access-form rest))))
  458.        ,store-form)))
  459.  
  460. (defmacro pop (place)
  461.   (when (symbolp place)
  462.         (return-from pop
  463.           (let ((temp (gensym)))
  464.             `(let ((,temp (car ,place)))
  465.                 (setq ,place (cdr ,place))
  466.                 ,temp))))
  467.   (multiple-value-bind (vars vals stores store-form access-form)
  468.       (get-setf-method place)
  469.     `(let* ,(mapcar #'list
  470.             (append vars stores)
  471.             (append vals (list (list 'cdr access-form))))
  472.        (prog1 (car ,access-form)
  473.               ,store-form))))
  474.